{*******************************************************}
{                                                       }
{       DevOnRails                                      }
{                                                       }
{       Copyright (C) 2012 Allan Gomes                  }
{                                                       }
{*******************************************************}

unit Rails.Utils;

interface

uses
  System.Classes, System.SysUtils, RTTI, System.Generics.Collections;

type
{$REGION 'TRailsUtils'}
  TRailsUtils = class
  public
    class function EncodeFile(const filename: String): ansistring; static;
    class procedure DecodeHexData(const Text: string; TargetStream: TStream); static;
    class function TryFreeAndNil(var Instace):Boolean; static;
    class function IsDateValid(ADateTime: string): Boolean; static;
    class procedure Reject(const aMessage:PWideChar); static;
    class function NumbersOnly(const Text: string; AExcept: TSysCharSet = []): string; static;
    class function IndentifyError(const Error: string): string; static;
    class function IndentifyExpected(const Error: string): string; static;
    class function IndentifyWarning(const Error: string): string; static;
    class function RemoveChars(const Text: string; Char: TSysCharSet): string; static;
    class function CharsOnly(const Text: string; Char: TSysCharSet): string; static;
    class function StringRepeat(const Text: string; Count: Integer): string; static;
    class function Zeros(const Value: Integer; Count: Integer): string; static;
    class function Split(value:string;separator:char):TStringList; static;
    class function TokenN(const aTokenList:string; aIndex:integer; aTokenSeparator:char='|'):string; static;
    class function EqualValues(source, destination: TValue): Boolean;
  end;
{$ENDREGION}

{$REGION 'RttiUtils'}
  TRttiUtils = class
  private
    class var ctx: TRttiContext;
  public
    //Methods
    class function MethodCall(AObject: TObject; AMethodName: string; AParameters: array of TValue): TValue; static;
    class function CreateObject(ARttiType: TRttiType): TObject; static;
    //Members
    class function GetProperty(Obj: TObject; const PropertyName: string): TValue;
    class procedure SetProperty(Obj: TObject; const PropertyName: string; const Value: TValue); static;
    class function GetField(Obj: TObject; const PropertyName: string): TValue;
    class procedure SetField(Obj: TObject; const PropertyName: string; const Value: TValue);
    class function GetFieldType(AProp: TRttiProperty): string;
    //Attributes
    class function GetAttribute<T: TCustomAttribute>(const Obj: TRttiObject): T; overload;
    class function GetAttribute<T: TCustomAttribute>(const Obj: TRttiType): T; overload;
    class function HasAttribute<T: TCustomAttribute>(const Obj: TRttiObject): Boolean;
  end;
{$ENDREGION}

function FieldFor(const PropertyName: string): string; inline;

implementation

uses
  Winapi.Windows, System.TypInfo;

function FieldFor(const PropertyName: string): string; inline;
begin
  Result := 'F' + PropertyName;
end;

{$REGION 'TRailsUtils'}
{ TRailsUtils }

class function TRailsUtils.EncodeFile(const filename: String): ansistring;
var
  MS: TMemoryStream;
begin
  MS := TMemoryStream.Create();
  try
    MS.LoadFromFile(filename);
    SetLength(Result, MS.Size*2);
    BinToHex(MS.Memory, PAnsichar(Result), MS.Size);
  finally
    MS.Free;
  end;
end;

class function TRailsUtils.EqualValues(source, destination: TValue): Boolean;
begin
  Result := AnsiCompareStr(source.ToString, destination.ToString) = 0;
end;

{Characters for the header}
class function TRailsUtils.CharsOnly(const Text: string;
  Char: TSysCharSet): string;
var
  I: Integer;
begin
  for I := 1 to Length(Text) do
    if CharInSet(Text[I], Char) then
      Result := Result+Text[I];
end;

class procedure TRailsUtils.DecodeHexData(const Text: string; TargetStream:TStream);
var
  Buf: PAnsiChar;
  Bufsize: Integer;
  I: Integer;
  LText: string;
begin
  Assert(Assigned(TargetStream),'DecodeHexData: TargetStream cannot be nil!');
  LText := Text;
  for I := Length(LText) downto 1 do
    if not CharInSet(LText[I],['0'..'9','a'..'f','A'..'F']) then
      Delete(LText, I, 1);
  if Length(LText) = 0 then
    Exit;
  Bufsize := Length(LText) div 2;
  GetMem(Buf, Bufsize);
  try
    HexToBin(PWideChar(LText), Buf, Bufsize);
    TargetStream.Write(Buf^, Bufsize);
  finally
    FreeMem(Buf);
  end;
end;

class function TRailsUtils.IndentifyError(const Error: string): string;
begin
  Result := 'Error: '+Error+'|';
end;

class function TRailsUtils.IndentifyExpected(const Error: string): string;
begin
  Result := 'Expected: '+Error+'|';
end;

class function TRailsUtils.IndentifyWarning(const Error: string): string;
begin
  Result := 'Warning: '+Error+'|';
end;

class function TRailsUtils.IsDateValid(ADateTime: string): Boolean;
var DateTime: TDateTime;
begin
  Result:= TryStrToDate(ADateTime,DateTime);
end;

class function TRailsUtils.NumbersOnly(const Text: string; AExcept: TSysCharSet): string;
var
  I: integer;
  S: string;
begin
  S := '';
  for I := 1 To Length(Text) Do
  begin
    if CharInSet(Text[I], ['0'..'9']) or (CharInSet(Text[I], AExcept)) then
      S := S + Text[I];
  end;
  result := S;
end;

class procedure TRailsUtils.Reject;
begin
  Abort;
end;

class function TRailsUtils.RemoveChars(const Text: string;
  Char: TSysCharSet): string;
var
  I: Integer;
begin
  for I := 1 to Length(Text) do
  if not CharInSet(Text[I], Char) then
    Result := Result+Text[I];
end;

class function TRailsUtils.Split(value: string; separator: char): TStringList;
var
  list : TStringList;
  aux  : String;
  i    : Integer;
begin

  i    := 0;
  aux  := '';
  list := TStringList.Create;

  if (Pos(separator, value) > 0) then
  begin
    Inc(i);
    aux  := TokenN(value, i, separator);

    if aux <> EmptyStr then
      list.Add(aux);

    while Aux <> '' do
    begin
      Inc(i);
      aux:= TokenN(value, i, separator);
      if aux <> EmptyStr then
        list.Add(aux);
    end;
  end
  else
    list.Add(value);

  result := list;
end;

class function TRailsUtils.StringRepeat(const Text: string;
  Count: Integer): string;
var
  I: Integer;
begin
  for I := 0 to Count do
    Result := Result+Text;
end;

class function TRailsUtils.TokenN(const aTokenList: string; aIndex: integer; aTokenSeparator: char): string;
var
  i,m,count:integer;
begin
  Result:='';
  count:=0;
  i:=1;
  while i<=Length(aTokenList) do
  begin
    m:=i;
    while (i<=Length(aTokenList)) and (aTokenList[i]<>aTokenSeparator) do
      Inc(i);
    Inc(count);
    if count=aIndex then
    begin
      Result:=Copy(aTokenList,m,i-m);
      Break;
    end;
    Inc(i);
  end;
end;

class function TRailsUtils.TryFreeAndNil(var Instace): Boolean;
begin
  Result := False;
  if Assigned(TObject(Instace)) then
  begin
    FreeAndNil(Instace);
    Result := True;
  end;
end;

class function TRailsUtils.Zeros(const Value: Integer; Count: Integer): string;
var
  V: string;
begin
  V := IntToStr(Value);
  Result := TRailsUtils.StringRepeat('0',Count-Length(V))+V;
end;
{$ENDREGION}

{$REGION 'TRttiUtils'}
{ TRttiUtils }

class function TRttiUtils.CreateObject(ARttiType: TRttiType): TObject;
var
  Method: TRttiMethod;
  metaClass: TClass;
begin
  metaClass := nil;
  Method := nil;
  for Method in ARttiType.GetMethods do
    if Method.HasExtendedInfo and Method.IsConstructor then
      if Length(Method.GetParameters) = 0 then
      begin
        metaClass := ARttiType.AsInstance.MetaclassType;
        Break;
      end;
  if Assigned(metaClass) then
    Result := Method.Invoke(metaClass, []).AsObject
  else
    raise Exception.Create('Cannot find a propert constructor for ' + ARttiType.ToString);
end;

class function TRttiUtils.GetAttribute<T>(const Obj: TRttiObject): T;
var
  Attr: TCustomAttribute;
begin
  Result := nil;
  for Attr in Obj.GetAttributes do
  begin
    if Attr.ClassType.InheritsFrom(T) then
      Exit(T(Attr));
  end;
end;

class function TRttiUtils.GetAttribute<T>(const Obj: TRttiType): T;
var
  Attr: TCustomAttribute;
begin
  Result := nil;
  for Attr in Obj.GetAttributes do
  begin
    if Attr.ClassType.InheritsFrom(T) then
      Exit(T(Attr));
  end;
end;

class function TRttiUtils.GetField(Obj: TObject; const PropertyName: string): TValue;
var
  Field: TRttiField;
  Prop: TRttiProperty;
  ARttiType: TRttiType;
begin
  ARttiType := ctx.GetType(Obj.ClassType);
  if not Assigned(ARttiType) then
    raise Exception.CreateFmt('Cannot get RTTI for type [%s]',
      [ARttiType.ToString]);
  Field := ARttiType.GetField(FieldFor(PropertyName));
  if Assigned(Field) then
    Result := Field.GetValue(Obj)
  else
  begin
    Prop := ARttiType.GetProperty(PropertyName);
    if not Assigned(Prop) then
      raise Exception.CreateFmt('Cannot get RTTI for property [%s.%s]',
        [ARttiType.ToString, PropertyName]);
    Result := Prop.GetValue(Obj);
  end;
end;

class function TRttiUtils.GetFieldType(AProp: TRttiProperty): string;
var
  _PropInfo: PTypeInfo;
begin
  _PropInfo := AProp.PropertyType.Handle;
  if _PropInfo.Kind in [tkString, tkWString, tkChar, tkWChar, tkLString, tkUString] then
    Result := 'string'
  else if _PropInfo.Kind in [tkInteger, tkInt64] then
    Result := 'integer'
  else if _PropInfo = TypeInfo(TDate) then
    Result := 'date'
  else if _PropInfo = TypeInfo(TDateTime) then
    Result := 'datetime'
  else if _PropInfo = TypeInfo(Currency) then
    Result := 'decimal'
  else if _PropInfo.Kind = tkFloat then
    Result := 'float'
  else if AProp.PropertyType.IsInstance and AProp.PropertyType.AsInstance.MetaclassType.InheritsFrom(TStream) then
    Result := 'blob'
  else
    Result := EmptyStr;
end;

class function TRttiUtils.GetProperty(Obj: TObject; const PropertyName: string): TValue;
var
  Prop: TRttiProperty;
  ARttiType: TRttiType;
begin
  ARttiType := ctx.GetType(Obj.ClassType);
  if not Assigned(ARttiType) then
    raise Exception.CreateFmt('Cannot get RTTI for type [%s]',
      [ARttiType.ToString]);
  Prop := ARttiType.GetProperty(PropertyName);
  if not Assigned(Prop) then
    raise Exception.CreateFmt('Cannot get RTTI for property [%s.%s]',
      [ARttiType.ToString, PropertyName]);
  if Prop.IsReadable then
    Result := Prop.GetValue(Obj)
  else
    raise Exception.CreateFmt('Property is not readable [%s.%s]',
      [ARttiType.ToString, PropertyName]);
end;

class function TRttiUtils.HasAttribute<T>(const Obj: TRttiObject): Boolean;
begin
  Result := Assigned(GetAttribute<T>(Obj));
end;

class function TRttiUtils.MethodCall(AObject: TObject; AMethodName: string; AParameters: array of TValue): TValue;
var
  m: TRttiMethod;
begin
  m := ctx.GetType(AObject.ClassInfo).GetMethod(AMethodName);
  if Assigned(m) then
    Result := m.Invoke(AObject, AParameters)
  else
    raise Exception.CreateFmt('Cannot find method "%s" in the object',
      [AMethodName]);
end;

class procedure TRttiUtils.SetField(Obj: TObject; const PropertyName: string; const Value: TValue);
var
  Field: TRttiField;
  Prop: TRttiProperty;
  ARttiType: TRttiType;
begin
  ARttiType := ctx.GetType(Obj.ClassType);
  if not Assigned(ARttiType) then
    raise Exception.CreateFmt('Cannot get RTTI for type [%s]',
      [ARttiType.ToString]);
  Field := ARttiType.GetField(FieldFor(PropertyName));
  if Assigned(Field) then
    Field.SetValue(Obj, Value)
  else
  begin
    Prop := ARttiType.GetProperty(PropertyName);
    if Assigned(Prop) then
      Prop.SetValue(Obj, Value)
    else
      raise Exception.CreateFmt('Cannot get RTTI for field or property [%s.%s]',
        [ARttiType.ToString, PropertyName]);
  end;
end;

class procedure TRttiUtils.SetProperty(Obj: TObject; const PropertyName: string; const Value: TValue);
var
  Prop: TRttiProperty;
  ARttiType: TRttiType;
begin
  ARttiType := ctx.GetType(Obj.ClassType);
  if not Assigned(ARttiType) then
    raise Exception.CreateFmt('Cannot get RTTI for type [%s]',
      [ARttiType.ToString]);
  Prop := ARttiType.GetProperty(PropertyName);
  if not Assigned(Prop) then
    raise Exception.CreateFmt('Cannot get RTTI for property [%s.%s]',
      [ARttiType.ToString, PropertyName]);
  if Prop.IsWritable then
    Prop.SetValue(Obj, Value)
  else
    raise Exception.CreateFmt('Property is not writeable [%s.%s]',
      [ARttiType.ToString, PropertyName]);
end;
{$ENDREGION}

initialization
  TRttiUtils.ctx := TRttiContext.Create;

end.
